sdk/samples/all in on code/Visual Studio 2008/VBExeCOMServer/ExeCOMServer.vb

   1 '****************************** Module Header ******************************'
   2 ' Module Name:  ExeCOMServer.vb
   3 ' Project:      VBExeCOMServer
   4 ' Copyright (c) Microsoft Corporation.
   5 '
   6 ' ExeCOMServer encapsulates the skeleton of an out-of-process COM server in
   7 ' VB.NET. The class implements the singleton design pattern and it's
   8 ' thread-safe. To start the server, call CSExeCOMServer.Instance.Run(). If
   9 ' the server is running, the function returns directly. Inside the Run method,
  10 ' it registers the class factories for the COM classes to be exposed from the
  11 ' COM server, and starts the message loop to wait for the drop of lock count
  12 ' to zero. When lock count equals zero, it revokes the registrations and
  13 ' quits the server.
  14 '
  15 ' The lock count of the server is incremented when a COM object is created,
  16 ' and it's decremented when the object is released (GC-ed). In order that the
  17 ' COM objects can be GC-ed in time, ExeCOMServer triggers GC every 5 seconds
  18 ' by running a Timer after the server is started.
  19 '
  20 ' This source is subject to the Microsoft Public License.
  21 ' See http://www.microsoft.com/opensource/licenses.mspx#Ms-PL.
  22 ' All other rights reserved.
  23 '
  24 ' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND,
  25 ' EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED
  26 ' WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
  27 '***************************************************************************'
  28
  29 #Region "Imports directives"
  30
  31 Imports System.Threading
  32
  33 #End Region
  34
  35
  36 Friend NotInheritable Class ExeCOMServer
  37
  38 #Region "Singleton Pattern"
  39
  40     Private Sub New()
  41     End Sub
  42
  43     Private Shared _instance As ExeCOMServer = New ExeCOMServer
  44     Public Shared ReadOnly Property Instance() As ExeCOMServer
  45         Get
  46             Return ExeCOMServer._instance
  47         End Get
  48     End Property
  49
  50 #End Region
  51
  52
  53     Private syncRoot As Object = New Object  ' For thread-sync in lock
  54     Private _bRunning As Boolean = False  ' Whether the server is running
  55
  56     ' The ID of the thread that runs the message loop
  57     Private _nMainThreadID As UInt32 = 0
  58
  59     ' The lock count (the number of active COM objects) in the server
  60     Private _nLockCnt As Integer = 0
  61
  62     ' The timer to trigger GC every 5 seconds
  63     Private _gcTimer As Timer
  64
  65     ''' <summary>
  66     ''' The method is call every 5 seconds to GC the managed heap after
  67     ''' the COM server is started.
  68     ''' </summary>
  69     ''' <param name="stateInfo"></param>
  70     Private Shared Sub GarbageCollect(ByVal stateInfo As Object)
  71         GC.Collect()  ' GC
  72     End Sub
  73
  74     Private _cookieSimpleObj As UInt32
  75
  76
  77     ''' <summary>
  78     ''' PreMessageLoop is responsible for registering the COM class
  79     ''' factories for the COM classes to be exposed from the server, and
  80     ''' initializing the key member variables of the COM server (e.g.
  81     ''' _nMainThreadID and _nLockCnt).
  82     ''' </summary>
  83     Private Sub PreMessageLoop()
  84
  85         '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  86         ' Register the COM class factories.
  87         '
  88
  89         Dim clsidSimpleObj As New Guid(SimpleObject.ClassId)
  90
  91         ' Register the SimpleObject class object
  92         Dim hResult As Integer = COMNative.CoRegisterClassObject( _
  93         clsidSimpleObj, New SimpleObjectClassFactory, CLSCTX.LOCAL_SERVER, _
  94         REGCLS.SUSPENDED Or REGCLS.MULTIPLEUSE, Me._cookieSimpleObj)
  95         If (hResult <> 0) Then
  96             Throw New ApplicationException( _
  97             "CoRegisterClassObject failed w/err 0x" & hResult.ToString("X"))
  98         End If
  99
 100         ' Register other class objects
 101         ' ...
 102
 103         ' Inform the SCM about all the registered classes, and begins
 104         ' letting activation requests into the server process.
 105         hResult = COMNative.CoResumeClassObjects
 106         If (hResult <> 0) Then
 107             ' Revoke the registration of SimpleObject on failure
 108             If (Me._cookieSimpleObj <> 0) Then
 109                 COMNative.CoRevokeClassObject(Me._cookieSimpleObj)
 110             End If
 111
 112             ' Revoke the registration of other classes
 113             ' ...
 114
 115             Throw New ApplicationException( _
 116             "CoResumeClassObjects failed w/err 0x" & hResult.ToString("X"))
 117         End If
 118
 119
 120         '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 121         ' Initialize member variables.
 122         '
 123
 124         ' Records the ID of the thread that runs the COM server so that
 125         ' the server knows where to post the WM_QUIT message to exit the
 126         ' message loop.
 127         Me._nMainThreadID = NativeMethod.GetCurrentThreadId
 128
 129         ' Records the count of the active COM objects in the server.
 130         ' When _nLockCnt drops to zero, the server can be shut down.
 131         Me._nLockCnt = 0
 132
 133         ' Start the GC timer to trigger GC every 5 seconds.
 134         Me._gcTimer = New Timer( _
 135         New TimerCallback(AddressOf ExeCOMServer.GarbageCollect), Nothing, _
 136         5000, 5000)
 137
 138     End Sub
 139
 140
 141     ''' <summary>
 142     ''' RunMessageLoop runs the standard message loop. The message loop
 143     ''' quits when it receives the WM_QUIT message.
 144     ''' </summary>
 145     Private Sub RunMessageLoop()
 146         Dim msg As MSG
 147         Do While NativeMethod.GetMessage(msg, IntPtr.Zero, 0, 0)
 148             NativeMethod.TranslateMessage((msg))
 149             NativeMethod.DispatchMessage((msg))
 150         Loop
 151     End Sub
 152
 153
 154     ''' <summary>
 155     ''' PostMessageLoop is called to revoke the registration of the COM
 156     ''' classes exposed from the server, and perform the cleanups.
 157     ''' </summary>
 158     Private Sub PostMessageLoop()
 159
 160         '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 161         ' Revoke the registration of the COM classes.
 162         '
 163
 164         ' Revoke the registration of SimpleObject
 165         If (Me._cookieSimpleObj <> 0) Then
 166             COMNative.CoRevokeClassObject(Me._cookieSimpleObj)
 167         End If
 168
 169         ' Revoke the registration of other classes
 170         ' ...
 171
 172
 173         '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 174         ' Perform the cleanup.
 175         '
 176
 177         ' Dispose the GC timer.
 178         If (Not Me._gcTimer Is Nothing) Then
 179             Me._gcTimer.Dispose()
 180         End If
 181
 182         ' Wait for any threads to finish.
 183         Thread.Sleep(1000)
 184
 185     End Sub
 186
 187
 188     ''' <summary>
 189     ''' Run the COM server. If the server is running, the function
 190     ''' returns directly.
 191     ''' </summary>
 192     ''' <remarks>The method is thread-safe.</remarks>
 193     Public Sub Run()
 194         SyncLock Me.syncRoot  ' Ensure thread-safe
 195             ' If the server is running, return directly
 196             If Me._bRunning Then
 197                 Return
 198             End If
 199             ' Indicate that the server is running now
 200             Me._bRunning = True
 201         End SyncLock
 202
 203         Try
 204             ' Call PreMessageLoop to initialize the member variables
 205             ' and register the class factories.
 206             Me.PreMessageLoop()
 207
 208             ' Run the message loop.
 209             Me.RunMessageLoop()
 210
 211             ' Call PostMessageLoop to revoke the registration.
 212             Me.PostMessageLoop()
 213         Finally
 214             Me._bRunning = False
 215         End Try
 216     End Sub
 217
 218
 219     ''' <summary>
 220     ''' Increase the lock count
 221     ''' </summary>
 222     ''' <returns>The new lock count after the increment</returns>
 223     ''' <remarks>The method is thread-safe.</remarks>
 224     Public Function Lock() As Integer
 225         Return Interlocked.Increment(Me._nLockCnt)
 226     End Function
 227
 228
 229     ''' <summary>
 230     ''' Decrease the lock count. When the lock count drops to zero, post
 231     ''' the WM_QUIT message to the message loop in the main thread to
 232     ''' shut down the COM server.
 233     ''' </summary>
 234     ''' <returns>The new lock count after the increment</returns>
 235     Public Function Unlock() As Integer
 236         Dim nRet As Integer = Interlocked.Decrement(Me._nLockCnt)
 237
 238         ' If lock drops to zero, attempt to terminate the server.
 239         If (nRet = 0) Then
 240             ' Post the WM_QUIT message to the main thread
 241             NativeMethod.PostThreadMessage( _
 242             _nMainThreadID, NativeMethod.WM_QUIT, UIntPtr.Zero, IntPtr.Zero)
 243         End If
 244         Return nRet
 245     End Function
 246
 247
 248     ''' <summary>
 249     ''' Get the current lock count.
 250     ''' </summary>
 251     ''' <returns></returns>
 252     Public Function GetLockCount() As Integer
 253         Return Me._nLockCnt
 254     End Function
 255
 256 End Class